home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1994 August: Tool Chest / Dev.CD Aug 94.toast / Tool Chest / Development Platforms / Macintosh Common Lisp Related / User Contributions / wilma-mixin.lisp < prev    next >
Encoding:
Text File  |  1994-06-16  |  13.2 KB  |  337 lines  |  [TEXT/CCL2]
  1. ;;; SEM 03/09/93 — wilma-mixin.lisp.  Wilma-mixin is like a Fred-mixin, but with 
  2. ;;; auto-fill.  The fill routine is based on pixel width (not number of chars) so that 
  3. ;;; it will work with proportional fonts.
  4. ;;;
  5. ;;; Paragraphs must be separated by a blank line.  (Otherwise, they may be joined 
  6. ;;; together when filling.)  Auto-fill can happen only on Space and Newline chars.  
  7. ;;; This takes care of the common cases without slowing down input too much.  There 
  8. ;;; will doubtless be times when things are not filled properly, so the user can force 
  9. ;;; the entire buffer to refill by typing Control-Meta-TAB (see the end of this file 
  10. ;;; for the key binding.)
  11. ;;; 
  12. ;;; I never quite got around to cleaning up the code for public release so you might
  13. ;;; find some bugs.  I hope you find it useful anyway.
  14. ;;;
  15. ;;; With gratitude to the net, I release this code to the public domain.  However, I 
  16. ;;; would appreciate it if you leave these comments.  Please send bug reports to the 
  17. ;;; author listed below.
  18. ;;; 
  19. ;;; Wilma-mixin.lisp, version 0.91
  20. ;;; 03/09/93 
  21. ;;; 
  22. ;;; Stephen E. Miner
  23. ;;; miner@tc.pw.com
  24.  
  25.  
  26. ;;; SEM 08/15/91 — New idea that's not implemented:  keep track of end-of-line
  27. ;;; before doing join since that's likely to be close to the next break.
  28.  
  29. (in-package "CL-USER")
  30.  
  31. #|
  32. ;;; This was my old definition, but now I use the internal function.
  33. (defun buffer-end-p (buffer &optional position)
  34.   (>= (buffer-position buffer position) (buffer-size buffer)))
  35. |#
  36.  
  37. (import 'ccl::buffer-end-p)
  38.  
  39.  
  40.  
  41. (defclass wilma-mixin (fred-mixin)
  42.   ()
  43.   (:default-initargs :wrap-p t :view-font '("Chicago" 12)))
  44.  
  45.  
  46. (defclass wilma-window (wilma-mixin fred-window)
  47.   ())
  48.   
  49.  
  50. ;;; SEM 10/08/91 — In b3 FRED-HPOS changed.  Bill St. Clair sent us the
  51. ;;; fred-unwrapped-hpos.
  52. (defmethod fred-unwrapped-hpos ((w fred-mixin) &optional pos)
  53.   "This recreates the behavior of the beta 2, FRED-HPOS."
  54.   (ccl::frec-hpos (ccl::frec w) pos))
  55.  
  56.  
  57. (defmethod wilma-horz-pos ((w fred-mixin) &optional pos)
  58.   (fred-unwrapped-hpos w pos))
  59.  
  60.  
  61. ;;; Implements auto-fill.  We don't care about return value.
  62. ;;; 
  63. ;;; SEM 03/06/92 — This function could definitely use some more work.
  64. (defmethod view-key-event-handler :around ((w wilma-mixin) char)
  65.   (if (eql char #\newline)
  66.     (let* ((buf (fred-buffer w))
  67.            (was-eob (buffer-end-p buf))
  68.            (was-eol (= (buffer-position buf) (buffer-line-end buf))))
  69.       ;; add the #\newline as usual
  70.       (call-next-method)
  71.       ;; Check previous line...
  72.       (when (wilma-line-needs-wrap-p w -1)
  73.         (let ((prev-start (buffer-line-start buf nil -1)))
  74.           ;; May need extra newline to separate paragraphs before refilling...
  75.           (unless (or was-eol was-eob) (buffer-insert buf #\newline))
  76.           (wilma-refill w prev-start)))
  77.       (unless was-eol
  78.         (wilma-refill w (buffer-line-start buf))))
  79.     ;; All other chars...
  80.     (call-next-method))
  81.   ;; The char has now been handled the usual way, but we have to check for a space
  82.   ;; that forces a wrap...
  83.   (when (and (eql char #\space) (wilma-line-needs-wrap-p w))
  84.     ;; Handle a new space that requires a wrap...
  85.     (let ((buf (fred-buffer w)))
  86.       (let ((was-eol (= (buffer-position buf) (buffer-line-end buf)))
  87.             (was-space (unless (buffer-end-p buf) (eql (buffer-char buf) #\space))))
  88.         (wilma-refill w (buffer-line-start buf))
  89.         ;; There's a lot of tricky stuff here to get the new space in the right place!
  90.         (cond ((eql (buffer-position buf) (buffer-line-start buf))
  91.                nil)
  92.               ((buffer-end-p buf)
  93.                ;; The space got wasted by the wrap
  94.                (buffer-insert buf #\space))
  95.               ((and was-space (eql (buffer-position buf) (buffer-line-end buf)))
  96.                (buffer-delete buf (buffer-position buf)))
  97.               ((eql (buffer-position buf) (buffer-line-end buf))
  98.                (buffer-insert buf #\space))
  99.               ((and was-eol (eql (buffer-char buf) #\space))
  100.                ; go forward over #\space
  101.                (move-mark buf))
  102.               (t nil))))
  103.     (fred-update w)))
  104.  
  105.  
  106. (defmethod set-view-size :after ((w wilma-mixin) h &optional v)
  107.   (declare (ignore h v))
  108.   (wilma-refill-buffer w)
  109.   (fred-update w))
  110.  
  111.  
  112. ;;; May not be adequate for multi-paragraph cutting and pasting, but reasonable for
  113. ;;; common cases.  The user can always force the entire buffer to refill by using 
  114. ;;; Control-Meta-Tab (see end of this file for key-binding.)
  115.  
  116. (defmethod paste :after ((w wilma-mixin))
  117.   (ed-fill-top-level w))
  118.  
  119. (defmethod cut :after ((w wilma-mixin))
  120.   (ed-fill-top-level w))
  121.  
  122. (defmethod clear :after ((w wilma-mixin))
  123.   (ed-fill-top-level w))
  124.  
  125.  
  126. ;;; Fills current paragraph...
  127. (defmethod ed-fill-top-level ((w wilma-mixin))
  128.   (let* ((buf (fred-buffer w))
  129.          ;; find start of section around current position...
  130.          (start (wilma-buf-section-start buf)))
  131.     (wilma-refill w start)))
  132.  
  133.  
  134. (defmethod wilma-refill :before ((w wilma-mixin) start)
  135.   (declare (ignore start))
  136.   (set-fred-hscroll w 0)
  137.   (fred-update w))
  138.  
  139. (defmethod wilma-refill ((w wilma-mixin) start)
  140.   (when start
  141.     (wilma-fill-section w start (wilma-pixel-width w) " ")))
  142.  
  143. (defmethod wilma-refill :after ((w wilma-mixin) start)
  144.   (declare (ignore start))
  145.   (fred-update w))
  146.  
  147.  
  148. ;;; SEM 08/14/91 — New and improved
  149. (defmethod wilma-refill-buffer ((w wilma-mixin))
  150.   (flet ((find-next-start (buf pos)
  151.            (buffer-not-char-pos buf #.(coerce '(#\space #\return) 'string)
  152.                                 :start pos)))
  153.     (let ((buf (fred-buffer w)))
  154.       ;; all the work is done by side-effects in WILMA-REFILL
  155.       (do ((next-start (find-next-start buf 0)
  156.                        (find-next-start buf (wilma-refill w next-start))))
  157.           ((or (not next-start) (buffer-end-p buf next-start)) nil)
  158.         ;; empty body
  159.         ))))
  160.  
  161.  
  162. (defun wilma-buf-paragraph-start-p (buffer line-start)
  163.   "Returns T if CH looks like it starts a paragraph, NIL otherwise."
  164.    (not (member (wilma-buf-line-non-wsp-char buffer line-start)
  165.                 '(nil #\space #\return #\linefeed #\tab #\Null))))
  166.  
  167. (defun wilma-buf-section-start (buf)
  168.   "Complicated way to find start of section around current position in BUF."
  169.   (let* ((bpos (buffer-line-start buf)) 
  170.          (bsize (buffer-size buf)))
  171.     ;; We have to be careful about the end of buffer, maybe should use BUFFER-END-P
  172.     ;; here.
  173.     (when (and (> bsize 0) (not (= bpos bsize))
  174.                (wilma-buf-paragraph-start-p buf bpos))
  175.       (do ((pos bpos)
  176.            (pastp nil))
  177.           (pastp pos)
  178.         (multiple-value-bind (next-start overflowp)
  179.                              (buffer-line-start buf pos -1)
  180.           (setq pastp 
  181.                 (or overflowp
  182.                     (not (wilma-buf-paragraph-start-p buf next-start))))
  183.           (unless pastp (setq pos next-start)))))))
  184.  
  185.  
  186. ;;; NOTE:  The 20 was determined empirically (read "KLUDGE").  The idea is
  187. ;;; WILMA-PIXEL-WIDTH gives a reasonable answer for the number of pixels used for text. 
  188. ;;; This number could probably use some tuning.
  189. (defmethod wilma-pixel-width ((w fred-window))
  190.   ;; subtracting for the scrollbar and border
  191.   (- (point-h (view-size w)) 20))
  192.  
  193. (defmethod wilma-pixel-width ((item dialog-item))
  194.   (- (point-h (view-size item)) (dialog-item-width-correction item)))
  195.  
  196. (defmethod wilma-pixel-width ((w simple-view))
  197.   (point-h (view-size w)))
  198.  
  199.  
  200. (defun wilma-buf-line-non-wsp-char (buffer line-start)
  201.   "First non-whitespace character in line starting at LINE-START in BUFFER or NIL
  202. if there isn't one."
  203.   (let ((first-non-wsp-pos 
  204.          (buffer-not-char-pos buffer #\space :start line-start
  205.                               :end (buffer-line-end buffer line-start))))
  206.     (when first-non-wsp-pos 
  207.       (buffer-char buffer first-non-wsp-pos))))
  208.  
  209. ;;; Normally checks current line, but LINE-COUNT adds offset (use -1 for previous line.)
  210. (defmethod wilma-line-needs-wrap-p ((w wilma-mixin) &optional (line-count 0))
  211.   (>= (wilma-horz-pos w (buffer-line-end (fred-buffer w) nil line-count))
  212.       (wilma-pixel-width w)))
  213.  
  214. (defun wilma-buf-strip-line (buffer start strip-char)
  215.   "Strips STRIP-CHAR (string or char or NIL for none) from beginning of line and 
  216. trailing spaces from line starting at START in BUFFER.  Caller must guarantee that 
  217. START is start of a line."
  218.   (when strip-char
  219.     (let* ((eoln (buffer-line-end buffer start))
  220.            (strip-pos (or (buffer-not-char-pos buffer strip-char :start start :end eoln)
  221.                         eoln)))
  222.       (buffer-delete buffer start strip-pos)))
  223.   (let* ((end (buffer-line-end buffer start))
  224.          (end-non-space (buffer-not-char-pos buffer #\space :start
  225.                                              start :end end :from-end t)))
  226.     (when (and end-non-space (< end-non-space end))
  227.       (buffer-delete buffer (1+ end-non-space) end))))
  228.  
  229.  
  230. ;;; SEM 08/15/91 — If you want double spaces after periods or other end of sentence
  231. ;;; characters you should fix up this function.
  232. (defun wilma-buf-join-prev-line (buffer start)
  233.   "Joins line starting at START to previous line in BUFFER."
  234.   (unless (zerop start)
  235.     (buffer-char-replace buffer #\space (1- start))))
  236.  
  237.  
  238. ;;; Fill-predicate is a function that returns T if the given char starts a line that
  239. ;;; should be filled...
  240. (defmethod wilma-fill-section ((w wilma-mixin) start pixel-width strip-char)
  241.   (let ((buf (fred-buffer w)))
  242.     (wilma-buf-strip-line buf start strip-char)
  243.     (loop
  244.       (setq start (wilma-wrap-line w start pixel-width))
  245.       (multiple-value-bind (next-start overflowp) (buffer-line-start buf start 1)
  246.         (when (or overflowp 
  247.                   (= next-start (buffer-size buf))
  248.                   (not (wilma-buf-paragraph-start-p buf next-start)))
  249.           (return next-start))
  250.         (wilma-buf-strip-line buf next-start strip-char)
  251.         (wilma-buf-join-prev-line buf next-start)       ;joins next to start line
  252.         ))))
  253.  
  254.  
  255.  
  256. ;;; Date: 14 Aug 91 15:36:19 U
  257. ;;; From: "Seth Powsner" <seth_powsner@yccatsmtp.ycc.yale.edu>
  258. ;;; [gives us a new version (not shown here).]
  259. ;;; 
  260. ;;; SEM -- This should be faster for long lines...  I made a few additional changes. 
  261. ;;; The big problem with the original code was that it was taken from a character-count
  262. ;;; based routine that already knew its goal-column, but in this case we have to
  263. ;;; search for it.   By the way, on long lines it would be faster to search from the
  264. ;;; front so we do that too.
  265.  
  266. (defmethod wilma-wrap-line ((w wilma-mixin) line-start pixel-width)
  267.   "Recursively wraps single line (as many times as necessary) and returns
  268. position of start of last resulting line.  Caller must guarantee that
  269. LINE-START is the position of a line."
  270.   (let* ((buffer (fred-buffer w))
  271.          (line-end (buffer-line-end buffer line-start))
  272.          (line-width (wilma-horz-pos w line-end)))
  273.     (if (<= line-width pixel-width)
  274.       line-start
  275.       (let ((break-pos (if (> line-width (* 2 pixel-width))
  276.                          ;; Search forward from start of long line...
  277.                          (do ((leading-space nil)
  278.                               (p (buffer-char-pos buffer #\space :start line-start
  279.                                                   :end line-end)
  280.                                  (buffer-char-pos buffer #\space :start (1+ p)
  281.                                                   :end line-end)))
  282.                              ((or (null p) (> (wilma-horz-pos w p) pixel-width))
  283.                               (or leading-space p))
  284.                            (setf leading-space p))
  285.                          ;; Search backward from end of not-so-long line
  286.                          (do ((trailing-space nil)
  287.                               (p (buffer-char-pos buffer #\space :start line-start
  288.                                                   :end line-end :from-end t)
  289.                                  (buffer-char-pos buffer #\space :start line-start
  290.                                                   :end p :from-end t)))
  291.                              ((or (null p) (<= (wilma-horz-pos w p) pixel-width))
  292.                               (or p trailing-space))
  293.                            (setf trailing-space p)))))
  294.         (if break-pos
  295.           (progn
  296.             (buffer-char-replace buffer #\newline break-pos)
  297.             (wilma-wrap-line w (1+ break-pos) pixel-width))
  298.           ;else, give up on a line of a single long word
  299.           line-start)))))
  300.  
  301.  
  302.  
  303.  
  304.  
  305. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  306. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  307.  
  308.  
  309. ;;; Most fred-windows won't do anything...
  310. (defmethod wilma-refill-buffer ((w fred-mixin))
  311.   (declare (ignore w))
  312.   nil)
  313.  
  314. ;;; Control-Meta-Tab will force refill of entire buffer.  It things don't look right, 
  315. ;;; give this a try...
  316. (unless (comtab-get-key *comtab* '(:control :meta #\tab))
  317.   (comtab-set-key *comtab* '(:control :meta #\tab) 'wilma-refill-buffer))
  318.  
  319.  
  320. #|
  321.  
  322. (setq www (make-instance 'wilma-window))
  323.  
  324. (defclass wilma-item (wilma-mixin editable-text-dialog-item)
  325.   ())
  326.  
  327. (setq w (make-instance 'window 
  328.           :view-subviews (list (make-instance 'wilma-item
  329.                                  :view-size #@(150 150)
  330.                                  :dialog-item-text "This is a test")
  331.                                (make-instance 'wilma-item
  332.                                  :view-size #@(150 150)
  333.                                  :scroll-p t
  334.                                  :dialog-item-text "This is not a test"))))
  335.  
  336. |#
  337.